home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / ISSUE23 / SYSFONT / F_FONT.PAS < prev    next >
Pascal/Delphi Source File  |  1997-03-22  |  2KB  |  107 lines
  1. unit F_Font;
  2.  
  3. interface
  4.  
  5. uses
  6.     Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.     StdCtrls, SysFont;
  8.  
  9. type
  10.     TForm1 = class(TForm)
  11.         Label1: TLabel;
  12.         Label2: TLabel;
  13.         Label3: TLabel;
  14.         Label4: TLabel;
  15.         Label5: TLabel;
  16.         Label6: TLabel;
  17.         Button1: TButton;
  18.         Button2: TButton;
  19.         procedure FormCreate(Sender: TObject);
  20.         procedure Button1Click(Sender: TObject);
  21.         procedure Button2Click(Sender: TObject);
  22.         procedure FormClose(Sender: TObject; var Action: TCloseAction);
  23.     private
  24.         { Private declarations }
  25.     public
  26.         { Public declarations }
  27.     end;
  28.  
  29. var
  30.     Form1: TForm1;
  31.  
  32. implementation
  33.  
  34. {$R *.DFM}
  35.  
  36. procedure TForm1.FormCreate(Sender: TObject);
  37. begin
  38.     Button1Click(Self);
  39. end;
  40.  
  41. procedure SetSysFont(ALabel: TLabel; AFont: TSysFont);
  42. var
  43.     TempFont: TFont;
  44.     strStyle: string[12];
  45.     strCaption: string;
  46. begin
  47.     TempFont := TFont.Create;
  48.     try
  49.  
  50.         GetSysFont(AFont, TempFont);
  51.         ALabel.Font := TempFont;
  52.         Case AFont of
  53.             sfCaptionFont:
  54.                 strCaption := 'Title Bar Caption Font = ';
  55.             sfSmCaptionFont:
  56.                 strCaption := 'Small Title Bar Caption Font = ';
  57.             sfMenuFont:
  58.                 strCaption := 'Menu & Selected Items Font = ';
  59.             sfStatusFont:
  60.                 strCaption := 'ToolTip Font = ';
  61.             sfMessageFont:
  62.                 strCaption := 'Message Box Font = ';
  63.             sfIconFont:
  64.                 strCaption := 'Icon Font = ';
  65.         end;
  66.  
  67.         strStyle := '';
  68.         If fsBold in TempFont.Style then
  69.             strStyle := 'Bold';
  70.         If fsItalic in TempFont.Style then
  71.             strStyle := strStyle + 'Italic';
  72.  
  73.         strCaption := strCaption +
  74.             TempFont.Name + ', ' + IntToStr(TempFont.Size) + 'pt.';
  75.  
  76.         If strStyle <> EmptyStr then
  77.             strCaption := strCaption + ', ' + strStyle;
  78.  
  79.         ALabel.Caption := strCaption;
  80.  
  81.     finally
  82.         TempFont.Free;
  83.     end;
  84. end;
  85.  
  86. procedure TForm1.Button1Click(Sender: TObject);
  87. begin
  88.     SetSysFont(Label1, sfCaptionFont);
  89.     SetSysFont(Label2, sfSmCaptionFont);
  90.     SetSysFont(Label3, sfMenuFont);
  91.     SetSysFont(Label4, sfStatusFont);
  92.     SetSysFont(Label5, sfMessageFont);
  93.     SetSysFont(Label6, sfIconFont);
  94. end;
  95.  
  96. procedure TForm1.Button2Click(Sender: TObject);
  97. begin
  98.     Close;
  99. end;
  100.  
  101. procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
  102. begin
  103.     Action := caFree;
  104. end;
  105.  
  106. end.
  107.